﻿<%
'''Json对象类
'''todo 待修改
Class ClassJson
	
	'''以字面编码多字节 Unicode 字符
	Private UnescapedUnicode
	
	'''所有的 " 转换成 \u0022
	Private HexQuot
	
	'''所有的 & 转换成 \u0026
	Private HexAmp
	
	'''所有的 ' 转换成 \u0027
	Private HexApos
	
	'''所有的 < 和 > 转换成 \u003C 和 \u003E
	Private HexTag
	
	'''不要编码/
	Private UnescapedSlashes
	
	Private s_cfg
	
	'''构造
	Private Sub Class_Initialize()		
		HexQuot = False
		HexAmp = False
		HexApos = False
		HexTag = False
		UnescapedSlashes = False
		UnescapedUnicode = False
		
		Set s_cfg = New AshapoConfig
	End Sub
	
	'''析构
	Private Sub Class_Terminate()
		Set s_cfg = Nothing
	End Sub
	
	'''设置编码时的参数选项
	'p_key:参数名
	'p_val:参数值
	Public Sub SetOption(Byval p_key, Byval p_val)
		Execute("Me." & p_key & "=" & Cstr(p_val))
	End Sub
	
	'''编码字符串
	Private Function escape(Byval p_str)
		'On Error Resume Next
		If UnescapedUnicode Then
			escape = p_str
			'''双引号处理
			If HexQuot Then
				escape = Replace(escape, """", "\u0022")
			Else
				escape = Replace(escape, """", "\""")
			End If
			'''&符号处理
			If HexQuot Then
				escape = Replace(escape, "&", "\u0026")
			End If
			'''单引号处理
			If HexApos Then
				escape = Replace(escape, "'", "\u0027")
			End If
			'''大于号、小于号处理
			If HexTag Then
				escape = Replace(escape, "<", "\u003C")
				escape = Replace(escape, ">", "\u003E")
			End If
			'''编码/
			If Not UnescapedSlashes Then
				escape = Replace(escape, "/", "\/")
			End If
		Else
			Dim t_scriptCtrl
			Set t_scriptCtrl = Server.CreateObject( s_cfg.Environment("MSScriptControl.ScriptControl") )
			t_scriptCtrl.Language = "JScript"
			t_scriptCtrl.AddCode "var result = null;"
			t_scriptCtrl.ExecuteStatement "result = escape(""" & Replace(p_str, """", "\""") & """).replace(/%u/gi, '\\u');"
			escape = t_scriptCtrl.CodeObject.result
			
			'''处理不需要编译字符
			escape = Replace(escape, "%20", " ") ''空格
			escape = Replace(escape, "%21", "!") ''感叹号
			'''双引号处理
			If HexQuot Then
				escape = Replace(escape, "%22", "\u0022")
			Else
				escape = Replace(escape, "%22", "\""")
			End If
			escape = Replace(escape, "%23", "#") ''井号
			escape = Replace(escape, "%24", "$") ''美元符号
			escape = Replace(escape, "%25", "%") ''百分号
			'''&符号处理
			If HexQuot Then
				escape = Replace(escape, "%26", "\u0026")
			Else
				escape = Replace(escape, "%26", "&")
			End If
			'''单引号处理
			If HexApos Then
				escape = Replace(escape, "%27", "\u0027")
			Else
				escape = Replace(escape, "%27", "'")
			End If
			escape = Replace(escape, "%28", "(") ''左括号
			escape = Replace(escape, "%29", ")") ''右括号
			escape = Replace(escape, "%2C", ",") ''逗号
			If Not UnescapedSlashes Then
				escape = Replace(escape, "/", "\/")
			End If
			escape = Replace(escape, "%3A", ":") ''冒号
			escape = Replace(escape, "%3B", ";") ''分号
			'''小于号处理
			If HexTag Then
				escape = Replace(escape, "%3C", "\u003C")
			Else
				escape = Replace(escape, "%3C", "<")
			End If
			escape = Replace(escape, "%3D", "=") ''等号
			'''大于号处理
			If HexTag Then
				escape = Replace(escape, "%3E", "\u003E")
			Else
				escape = Replace(escape, "%3E", ">")
			End If
			escape = Replace(escape, "%3F", "?") ''问号
			escape = Replace(escape, "%5B", "[") ''[符号
			escape = Replace(escape, "%5C", "\\") ''\符号
			escape = Replace(escape, "%5D", "]") ''[符号
			escape = Replace(escape, "%5E", "^") ''^符号
			escape = Replace(escape, "%60", "`") ''`符号
			escape = Replace(escape, "%7B", "{") ''{符号
			escape = Replace(escape, "%7C", "|") ''|符号
			escape = Replace(escape, "%7D", "}") ''}符号
			escape = Replace(escape, "%7E", "~") ''~符号
		End If		
		If Err.Number <> 0 Then
			escape = ""
		End If
	End Function
	
	
	
	'''将Dictionary对象或数组编译成json字符串
	Public Function [Encode](Byval p_objt)
		Dim t_i, t_b, t_left, t_right, t_mid
		If IsArray(p_objt) Then ''数组
			t_left = "["
			t_right = "]"
			t_mid = ""
			t_b = UBound(p_objt)
			For t_i = 0 To t_b
				t_mid = t_mid & [Encode](p_objt(t_i))
				If t_i < t_b Then
					t_mid = t_mid & ","
				End If
			Next
		ElseIf TypeName(p_objt) = "Dictionary" Then ''对象
			t_left = "{"
			t_right = "}"
			t_mid = ""
			t_b = p_objt.Count - 1
			Dim t_k, t_v
			t_k = p_objt.Keys
			t_v = p_objt.Items
			For t_i = 0 To t_b
				t_mid = t_mid & """" & t_k(t_i) & """" & ":"
				t_mid = t_mid & [Encode](t_v(t_i))
				If t_i < t_b Then
					t_mid = t_mid & ","
				End If
			Next
		Else ''标量
			t_left = ""
			t_right = ""
			t_mid = ""
			Select Case VarType(p_objt)
			Case VbNull
				t_mid = "null"
			Case VbInteger, VbLong, VbSingle, VbDouble
				t_mid = Cstr(p_objt)
			Case VbCurrency, VbDate, VbString
				t_mid = """" & escape(p_objt) & """"
			Case vbBoolean
				t_mid = IIF(p_objt, "true", "false")
			Case Else
				''出错
				t_mid = """ERROR:" & VarType(p_objt) & """"
				[Encode] = False
				Exit Function
			End Select
		End If
		[Encode] = t_left & t_mid & t_right
	End Function
	
		
	'''将json字符串解析成json对象
	'''todo 暂未启用
	Public Function [Decode](Byval p_json)
		On Error Resume Next
		Dim t_scriptCtrl
		Set t_scriptCtrl = Server.CreateObject("MSScriptControl.ScriptControl")
		t_scriptCtrl.Language = "JScript"
		t_scriptCtrl.AddCode "Array.prototype.get = function(x){ return this[x]; }; var result = null;"
		t_scriptCtrl.ExecuteStatement "result = " & p_json & ";"
		Set [Decode] = t_scriptCtrl.CodeObject.result
		If Err.Number <> 0 Then
			Set [Decode] = Nothing
		End If
	End Function
End Class
%>